Optional Paint.f

{ Surface drawing wordset

The way things work right now is that alpha blending is not exactly enabled.  When I need, I will add functions to enable/disable it.. 10/10

}

Requires SORA\Drawing
Requires Sprig
Requires Vectors

Only Forth Definitions

requires sdl

also sdl-surfaces

0 value fill-color
0 value stop-color
0 value area-color
-? 0 value s

: sdl-pixel   ( surface x y -- addr )
   third ->w @ * + cells swap ->pixels @ + ;

{ pad !
   pad c@ 8 lshift
   pad 1 + c@ or 8 lshift
   pad 2 + c@ or 8 lshift
   pad 3 + c@ or ; }

: (rgba)  ( val -- val )
   bgra<>rgba ;

{
: (outline-fill)   ( x y -- )
   locals| y x |
   x 0< if exit then
   y 0< if exit then
   x s ->w @ >= if exit then
   y s ->h @ >= if exit then
   s x y pixel dup @ dup fill-color = swap stop-color = or if drop exit then
   fill-color swap !
   x 1+ y recurse
   x y 1+ recurse
   x 1- y recurse
   x y 1- recurse ;

: outline-fill  ( surface x y fill-color stop-color -- )
   to stop-color to fill-color rot to s
   (outline-fill) ;


: (flood-fill)   ( x y -- )
   locals| y x |
   x 0< if exit then
   y 0< if exit then
   x s ->w @ >= if exit then
   y s ->h @ >= if exit then
   s x y sdl-pixel dup @ dup fill-color = swap area-color <> or if drop exit then
   fill-color swap !
   x 1+ y recurse
   x y 1+ recurse
   x 1- y recurse
   x y 1- recurse ;

: floodfill  ( surface x y fill-color -- )
   to fill-color rot to s
   2dup sdl-pixel @ to area-color
   (flood-fill) ;
}

wordlist dup constant painting +order

0 Value canvas

: [+paint]  painting +order ; immediate
: [-paint]  painting -order ; immediate


definitions

create pen 0 , 0 ,

: onto  ( surface -- )
   to canvas ;

: at   pen 2v! ;
: +at   pen 2v+! ;

: dot  ( color -- )
   (rgba) >r canvas pen 2v@ r> SPG_Pixel ;

: rect  ( w h color -- )
   (rgba) locals| color h w |
   canvas pen 2v@ w h 2over 2+ color SPG_Rect ;

: rectf  ( w h color -- )
   (rgba) locals| color h w |
   canvas pen 2v@ w h 2over 2+ color SPG_RectFilled ;

: line   ( x2 y2 color -- )
   (rgba) locals| color y2 x2 |
   canvas pen 2v@ x2 y2 color SPG_Line  ;

: oval  ( r1 r2 color -- )
   (rgba) locals| color r2 r1 |
   canvas pen 2v@ r1 s>f r2 s>f color SPG_Ellipse ;

: ovalf   ( r1 r2 color -- )
   (rgba) locals| color r2 r1 |
   canvas pen 2v@ r1 s>f r2 s>f color SPG_EllipseFilled ;

: circle   ( radius color -- )
   (rgba) >r s>f canvas pen 2v@ r> SPG_Circle ;

: circlef   ( radius color -- )
   (rgba) >r s>f canvas pen 2v@ r> SPG_CircleFilled ;

: floodfill  ( color -- )
   (rgba) >r canvas pen 2v@ r> SPG_FloodFill ;

painting -order
only forth definitions


\ =========================================================
\ Painting Images

create temprect   8 allot

: set-cliprect   ( cliprect image -- )
   swap  temprect rect!
   ->surface @  temprect  SDL_SetClipRect  ;

: blit  ( image1 image2 -- )
   @pen SPG_DrawBlit ;

0 value img
[+paint] also sdl-surfaces
: (begin-paint)  ( image -- ) dup to img  ->surface @ onto ;
: begin-paint
   s" (begin-paint) [+paint]" evaluate ; immediate
: (end-paint)   ( -- )   img dup ->surface @ ->cliprect update-texture ;
: end-paint
   s" (end-paint) [-paint]" evaluate ; immediate
[-paint] previous

: pixel@  ( image x y -- color )
   2>r ->surface @ 2r> SPG_GetPixel ;

